home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / XSCHEME000 / h / xscheme < prev    next >
Text File  |  1992-04-27  |  14KB  |  497 lines
  1. /* xscheme.h - xscheme definitions */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include <stdio.h>
  7. #include <ctype.h>
  8. #include <setjmp.h>
  9.  
  10. /* AFMT        printf format for addresses ("%x") */
  11. /* OFFTYPE    number the size of an address (int) */
  12. /* FIXTYPE    data type for fixed point numbers (long) */
  13. /* ITYPE    fixed point input conversion routine type (long atol()) */
  14. /* ICNV        fixed point input conversion routine (atol) */
  15. /* IFMT        printf format for fixed point numbers ("%ld") */
  16. /* FLOTYPE    data type for floating point numbers (float) */
  17. /* FFMT        printf format for floating point numbers (%.15g) */
  18.  
  19. /* for the Lightspeed C compiler - Macintosh */
  20. #ifdef LSC
  21. #define AFMT        "%lx"
  22. #define OFFTYPE        long
  23. #define NIL        (void *)0
  24. #define MACINTOSH
  25. #endif
  26.  
  27. /* for the UNIX System V C compiler */
  28. #ifdef UNIX
  29. #endif
  30.  
  31. /* for the Aztec C compiler - Amiga */
  32. #ifdef AZTEC_AMIGA
  33. #define AFMT        "%lx"
  34. #define OFFTYPE        long
  35. #endif
  36.  
  37. /* for the Mark Williams C compiler - Atari ST */
  38. #ifdef MWC
  39. #define AFMT        "%lx"
  40. #define OFFTYPE        long
  41. #endif
  42.  
  43. /* for the Microsoft C 6.0 compiler */
  44. #ifdef MSC
  45. #ifndef MSDOS
  46. #define MSDOS
  47. #endif
  48. #define SEGADDR
  49. #endif
  50.  
  51. /* for the Turbo (Borland) C compiler */
  52. #ifdef TURBOC
  53. #ifndef MSDOS
  54. #define MSDOS
  55. #endif
  56. #define SEGADDR
  57. #endif
  58.  
  59. /* for the Zortec C++ compiler */
  60. #ifdef ZTC
  61. #ifndef MSDOS
  62. #define MSDOS    1
  63. #endif
  64. #define SEGADDR
  65. void free(void *);
  66. #endif
  67.  
  68. /* for the TopSpeed C compiler */
  69. #ifdef TSC
  70. #ifndef MSDOS
  71. #define MSDOS    1
  72. #endif
  73. #define SEGADDR
  74. #endif
  75.  
  76. /* for the Watcom C compiler */
  77. #ifdef WTC
  78. #ifndef MSDOS
  79. #define MSDOS
  80. #endif
  81. #endif
  82.  
  83. /* for the Metaware High C compiler */
  84. #ifdef HIGHC
  85. #ifndef MSDOS
  86. #define MSDOS
  87. #endif
  88. #endif
  89.  
  90. /* for the Intel Code Builder C compiler */
  91. #ifdef CODEBLDR
  92. #ifndef MSDOS
  93. #define MSDOS
  94. #endif
  95. #endif
  96.  
  97. /* for the Microway NDP C compiler */
  98. #ifdef NDPC
  99. #ifndef MSDOS
  100. #define MSDOS
  101. #endif
  102. #endif
  103.  
  104. /* for the MS-DOS compilers */
  105. #ifdef MSDOS
  106. #define AFMT        "%lx"
  107. #define OFFTYPE        long
  108. #endif
  109.  
  110. /* for acorn Archimedes */
  111. #ifdef ARC
  112. #define oserror xoserror
  113. #define osclose fclose
  114. #define osaopen osopen
  115. #define osbopen osopen
  116. #define osaputc fputc
  117. #define osbputc fputc
  118. #define osagetc fgetc
  119. #define osbgetc fgetc
  120. #define ostell ftell
  121. #define osseek fseek
  122. #endif
  123.  
  124. /* for segmented addresses on Intel processors */
  125. #ifdef SEGADDR
  126. #define INSEGMENT(n,s)    ((unsigned long)(n) >> 16 \
  127.               == (unsigned long)(s) >> 16)
  128. #endif
  129.  
  130.  
  131. /* size of each type of memory segment */
  132. #ifndef NSSIZE
  133. #define NSSIZE    4000    /* number of nodes per node segment */
  134. #endif
  135. #ifndef VSSIZE
  136. #define VSSIZE    10000    /* number of LVAL's per vector segment */
  137. #endif
  138.  
  139. /* default important definitions */
  140. #ifndef AFMT
  141. #define AFMT        "%x"
  142. #endif
  143. #ifndef OFFTYPE
  144. #define OFFTYPE        int
  145. #endif
  146. #ifndef FIXTYPE
  147. #define FIXTYPE        long
  148. #endif
  149. #ifndef ITYPE
  150. #define ITYPE        long atol()
  151. #endif
  152. #ifndef ICNV
  153. #define ICNV(n)        atol(n)
  154. #endif
  155. #ifndef IFMT
  156. #define IFMT        "%ld"
  157. #endif
  158. #ifndef FLOTYPE
  159. #define FLOTYPE        double
  160. #endif
  161. #ifndef FFMT
  162. #define FFMT        "%.15g"
  163. #endif
  164. #ifndef SFIXMIN
  165. #define SFIXMIN        -1048576
  166. #define SFIXMAX        1048575
  167. #endif
  168. #ifndef INSEGMENT
  169. #define INSEGMENT(n,s)    ((n) >= &(s)->ns_data[0] \
  170.                       && (n) <  &(s)->ns_data[0] + (s)->ns_size)
  171. #endif
  172. #ifndef VCOMPARE
  173. #define VCOMPARE(f,s,t)    ((f) + (s) <= (t))
  174. #endif
  175. /* added by GTK to aid portability */
  176. #ifndef VOID
  177. #       ifdef __STDC__
  178. #               define VOID void
  179. #       else
  180. #               define VOID
  181. #       endif
  182. #endif
  183.  
  184. /* useful definitions */
  185. #define TRUE    1
  186. #define FALSE    0
  187. #ifndef NIL
  188. #define NIL    (LVAL)0
  189. #endif
  190.  
  191. /* program limits */
  192. #define STRMAX        100        /* maximum length of a string constant */
  193. #define HSIZE        199        /* symbol hash table size */
  194. #define SAMPLE        100        /* control character sample rate */
  195.  
  196. /* stack manipulation macros */
  197. #define check(n)    { if (xlsp - (n) < xlstkbase) xlstkover(); }
  198. #define cpush(v)    { if (xlsp > xlstkbase) push(v); else xlstkover(); }
  199. #define push(v)        (*--xlsp = (v))
  200. #define pop()        (*xlsp++)
  201. #define top()        (*xlsp)
  202. #define settop(v)    (*xlsp = (v))
  203. #define drop(n)        (xlsp += (n))
  204.  
  205. /* argument list parsing macros */
  206. #define xlgetarg()    (testarg(nextarg()))
  207. #define xllastarg()    {if (xlargc != 0) xltoomany();}
  208. #define xlpoprest()    {xlsp += xlargc;}
  209. #define testarg(e)    (moreargs() ? (e) : xltoofew())
  210. #define typearg(tp)    (tp(*xlsp) ? nextarg() : xlbadtype(*xlsp))
  211. #define nextarg()    (--xlargc, *xlsp++)
  212. #define moreargs()    (xlargc > 0)
  213.  
  214. /* macros to get arguments of a particular type */
  215. #define xlgacons()    (testarg(typearg(consp)))
  216. #define xlgalist()    (testarg(typearg(listp)))
  217. #define xlgasymbol()    (testarg(typearg(symbolp)))
  218. #define xlgastring()    (testarg(typearg(stringp)))
  219. #define xlgaobject()    (testarg(typearg(objectp)))
  220. #define xlgafixnum()    (testarg(typearg(fixp)))
  221. #define xlganumber()    (testarg(typearg(numberp)))
  222. #define xlgachar()    (testarg(typearg(charp)))
  223. #define xlgavector()    (testarg(typearg(vectorp)))
  224. #define xlgaport()    (testarg(typearg(portp)))
  225. #define xlgaiport()    (testarg(typearg(iportp)))
  226. #define xlgaoport()    (testarg(typearg(oportp)))
  227. #define xlgaclosure()    (testarg(typearg(closurep)))
  228. #define xlgaenv()    (testarg(typearg(envp)))
  229.  
  230. /* node types */
  231. #define FREE        0
  232. #define CONS        1
  233. #define SYMBOL        2
  234. #define FIXNUM        3
  235. #define FLONUM        4
  236. #define STRING        5
  237. #define OBJECT        6
  238. #define PORT        7
  239. #define VECTOR        8
  240. #define CLOSURE        9
  241. #define METHOD        10
  242. #define CODE        11
  243. #define SUBR        12
  244. #define XSUBR        13
  245. #define CSUBR        14
  246. #define CONTINUATION    15
  247. #define CHAR        16
  248. #define PROMISE        17
  249. #define ENV        18
  250.  
  251. /* node flags */
  252. #define MARK        1
  253. #define LEFT        2
  254.  
  255. /* port flags */
  256. #define PF_INPUT    1
  257. #define PF_OUTPUT    2
  258. #define PF_BINARY    4
  259.  
  260. /* new node access macros */
  261. #define ntype(x)    ((OFFTYPE)(x) & 1 ? FIXNUM : (x)->n_type)
  262.  
  263. /* macro to determine if a non-nil value is a pointer */
  264. #define ispointer(x)    (((OFFTYPE)(x) & 1) == 0)
  265.  
  266. /* type predicates */                   
  267. #define atom(x)        ((x) == NIL || ntype(x) != CONS)
  268. #define null(x)        ((x) == NIL)
  269. #define listp(x)    ((x) == NIL || ntype(x) == CONS)
  270. #define numberp(x)    ((x) && (ntype(x) == FIXNUM || ntype(x) == FLONUM))
  271. #define boundp(x)    (getvalue(x) != s_unbound)
  272. #define iportp(x)    (portp(x) && (getpflags(x) & PF_INPUT) != 0)
  273. #define oportp(x)    (portp(x) && (getpflags(x) & PF_OUTPUT) != 0)
  274.  
  275. /* basic type predicates */                   
  276. #define consp(x)    ((x) && ntype(x) == CONS)
  277. #define stringp(x)    ((x) && ntype(x) == STRING)
  278. #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
  279. #define portp(x)    ((x) && ntype(x) == PORT)
  280. #define objectp(x)    ((x) && ntype(x) == OBJECT)
  281. #define fixp(x)        ((x) && ntype(x) == FIXNUM)
  282. #define floatp(x)    ((x) && ntype(x) == FLONUM)
  283. #define vectorp(x)    ((x) && ntype(x) == VECTOR)
  284. #define closurep(x)    ((x) && ntype(x) == CLOSURE)
  285. #define continuationp(x) ((x) && ntype(x) == CONTINUATION)
  286. #define codep(x)    ((x) && ntype(x) == CODE)
  287. #define methodp(x)    ((x) && ntype(x) == METHOD)
  288. #define subrp(x)    ((x) && ntype(x) == SUBR)
  289. #define xsubrp(x)    ((x) && ntype(x) == XSUBR)
  290. #define charp(x)    ((x) && ntype(x) == CHAR)
  291. #define promisep(x)    ((x) && ntype(x) == PROMISE)
  292. #define envp(x)        ((x) && ntype(x) == ENV)
  293. #define booleanp(x)    ((x) == NIL || ntype(x) == BOOLEAN)
  294.  
  295. /* vector update macro
  296.    This is necessary because the memory pointed to by the n_vdata field
  297.    of a vector object can move during a garbage collection.  This macro
  298.    guarantees that evaluation happens in the right order.
  299. */
  300. #define vupdate(x,i,v)    { LVAL vutmp=(v); (x)->n_vdata[i] = vutmp; }
  301.  
  302. /* cons access macros */
  303. #define car(x)        ((x)->n_car)
  304. #define cdr(x)        ((x)->n_cdr)
  305. #define rplaca(x,y)    ((x)->n_car = (y))
  306. #define rplacd(x,y)    ((x)->n_cdr = (y))
  307.  
  308. /* symbol access macros */
  309. #define getvalue(x)     ((x)->n_vdata[0])
  310. #define setvalue(x,v)     vupdate(x,0,v)
  311. #define getpname(x)     ((x)->n_vdata[1])
  312. #define setpname(x,v)     vupdate(x,1,v)
  313. #define getplist(x)     ((x)->n_vdata[2])
  314. #define setplist(x,v)     vupdate(x,2,v)
  315. #define SYMSIZE        3
  316.  
  317. /* vector access macros */
  318. #define getsize(x)    ((x)->n_vsize)
  319. #define getelement(x,i)    ((x)->n_vdata[i])
  320. #define setelement(x,i,v) vupdate(x,i,v)
  321.  
  322. /* object access macros */
  323. #define getclass(x)    ((x)->n_vdata[1])
  324. #define setclass(x,v)    vupdate(x,1,v)
  325. #define getivar(x,i)    ((x)->n_vdata[i])
  326. #define setivar(x,i,v)    vupdate(x,i,v)
  327.  
  328. /* promise access macros */
  329. #define getpproc(x)    ((x)->n_car)
  330. #define setpproc(x,v)    ((x)->n_car = (v))
  331. #define getpvalue(x)    ((x)->n_cdr)
  332. #define setpvalue(x,v)    ((x)->n_cdr = (v))
  333.  
  334. /* closure access macros */
  335. #define getcode(x)    ((x)->n_car)
  336. #define getenv(x)    ((x)->n_cdr)
  337.  
  338. /* code access macros */
  339. #define getbcode(x)        ((x)->n_vdata[0])
  340. #define setbcode(x,v)        vupdate(x,0,v)
  341. #define getcname(x)        ((x)->n_vdata[1])
  342. #define setcname(x,v)        vupdate(x,1,v)
  343. #define getvnames(x)        ((x)->n_vdata[2])
  344. #define setvnames(x,v)        vupdate(x,2,v)
  345. #define FIRSTLIT        3
  346.  
  347. /* fixnum/flonum/character access macros */
  348. #define getfixnum(x)    ((OFFTYPE)(x) & 1 ? getsfixnum(x) : (x)->n_int)
  349. #define getflonum(x)    ((x)->n_flonum)
  350. #define getchcode(x)    ((x)->n_chcode)
  351.  
  352. /* small fixnum access macros */
  353. #define cvsfixnum(x)    ((LVAL)(((OFFTYPE)x << 1) | 1))
  354. #define getsfixnum(x)    ((FIXTYPE)((OFFTYPE)(x) >> 1))
  355.  
  356. /* string access macros */
  357. #define getstring(x)    ((char *)(x)->n_vdata)
  358. #define getslength(x)    ((x)->n_vsize)
  359.  
  360. /* iport/oport access macros */
  361. #define getfile(x)    ((x)->n_fp)
  362. #define setfile(x,v)    ((x)->n_fp = (v))
  363. #define getsavech(x)    ((x)->n_savech)
  364. #define setsavech(x,v)    ((x)->n_savech = (v))
  365. #define getpflags(x)    ((x)->n_pflags)
  366. #define setpflags(x,v)    ((x)->n_pflags = (v))
  367.  
  368. /* subr access macros */
  369. #define getsubr(x)    ((x)->n_subr)
  370. #define getoffset(x)    ((x)->n_offset)
  371.  
  372. /* list node */
  373. #define n_car        n_info.n_xlist.xl_car
  374. #define n_cdr        n_info.n_xlist.xl_cdr
  375.  
  376. /* integer node */
  377. #define n_int        n_info.n_xint.xi_int
  378.  
  379. /* flonum node */
  380. #define n_flonum    n_info.n_xflonum.xf_flonum
  381.  
  382. /* character node */
  383. #define n_chcode    n_info.n_xchar.xc_chcode
  384.  
  385. /* file pointer node */
  386. #define n_fp        n_info.n_xfptr.xf_fp
  387. #define n_savech    n_info.n_xfptr.xf_savech
  388. #define n_pflags    n_info.n_xfptr.xf_pflags
  389.  
  390. /* vector/object node */
  391. #define n_vsize        n_info.n_xvect.xv_size
  392. #define n_vdata        n_info.n_xvect.xv_data
  393.  
  394. /* subr node */
  395. #define n_subr        n_info.n_xsubr.xs_subr
  396. #define n_offset    n_info.n_xsubr.xs_offset
  397.  
  398. /* node structure */
  399. typedef struct node {
  400.     char n_type;        /* type of node */
  401.     char n_flags;        /* flag bits */
  402.     union ninfo {         /* value */
  403.     struct xlist {        /* list node (cons) */
  404.         struct node *xl_car;    /* the car pointer */
  405.         struct node *xl_cdr;    /* the cdr pointer */
  406.     } n_xlist;
  407.     struct xint {        /* integer node */
  408.         FIXTYPE xi_int;        /* integer value */
  409.     } n_xint;
  410.     struct xflonum {    /* flonum node */
  411.         FLOTYPE xf_flonum;        /* flonum value */
  412.     } n_xflonum;
  413.     struct xchar {        /* character node */
  414.         int xc_chcode;        /* character code */
  415.     } n_xchar;
  416.     struct xfptr {        /* file pointer node */
  417.         FILE *xf_fp;        /* the file pointer */
  418.         short xf_savech;        /* lookahead character for input files */
  419.         short xf_pflags;        /* port flags */
  420.     } n_xfptr;
  421.     struct xvect {        /* vector node */
  422.         int xv_size;        /* vector size */
  423.         struct node **xv_data;    /* vector data */
  424.     } n_xvect;
  425.     struct xsubr {        /* subr/fsubr node */
  426.         struct node *(*xs_subr)();    /* function pointer */
  427.         int xs_offset;        /* offset into funtab */
  428.     } n_xsubr;
  429.     } n_info;
  430. } NODE,*LVAL;
  431.  
  432. /* memory allocator definitions */
  433.  
  434. /* macros to compute the size of a segment */
  435. #define nsegsize(n) (sizeof(NSEGMENT)+((n)-1)*sizeof(struct node))
  436. #define vsegsize(n) (sizeof(VSEGMENT)+((n)-1)*sizeof(LVAL))
  437.  
  438. /* macro to convert a byte size to a word size */
  439. #define btow_size(n)    (((n) + sizeof(LVAL) - 1) / sizeof(LVAL))
  440.  
  441. /* node segment structure */
  442. typedef struct nsegment {
  443.     struct nsegment *ns_next;    /* next node segment */
  444.     unsigned int ns_size;    /* number of nodes in this segment */
  445.     struct node ns_data[1];    /* segment data */
  446. } NSEGMENT;
  447.  
  448. /* vector segment structure */
  449. typedef struct vsegment {
  450.     struct vsegment *vs_next;    /* next vector segment */
  451.     LVAL *vs_free;        /* next free location in this segment */
  452.     LVAL *vs_top;        /* top of segment (plus one) */
  453.     LVAL vs_data[1];        /* segment data */
  454. } VSEGMENT;
  455.  
  456. /* function definition structure */
  457. typedef struct {
  458.     char *fd_name;    /* function name */
  459.     LVAL (*fd_subr)();    /* function entry point */
  460. } FUNDEF;
  461.  
  462. /* external variables */
  463. extern LVAL *xlstkbase;     /* base of value stack */
  464. extern LVAL *xlstktop;        /* top of value stack */
  465. extern LVAL *xlsp;            /* value stack pointer */
  466. extern int xlargc;        /* argument count for current call */
  467.  
  468. /* external routine declarations */
  469. #ifdef __STDC__
  470. #include "xsproto.h"
  471. #else
  472. extern LVAL cons();        /* (cons x y) */
  473. extern LVAL xlenter();        /* enter a symbol */
  474. extern LVAL xlgetprop();    /* get the value of a property */
  475. extern LVAL cvsymbol();     /* convert a string to a symbol */
  476. extern LVAL cvstring();     /* convert a string */
  477. extern LVAL cvfixnum();     /* convert a fixnum */
  478. extern LVAL cvflonum();           /* convert a flonum */
  479. extern LVAL cvchar();         /* convert a character */
  480. extern LVAL cvclosure();    /* convert code and an env to a closure */
  481. extern LVAL cvmethod();        /* convert code and an env to a method */
  482. extern LVAL cvsubr();        /* convert a function into a subr */
  483. extern LVAL cvport();        /* convert a file pointer to an input port */
  484. extern LVAL cvpromise();    /* convert a procedure to a promise */
  485. extern LVAL newstring();    /* create a new string */
  486. extern LVAL newobject();    /* create a new object */
  487. extern LVAL newvector();    /* create a new vector */
  488. extern LVAL newcode();        /* create a new code object */
  489. extern LVAL newcontinuation();    /* create a new continuation object */
  490. extern LVAL newframe();        /* create a new environment frame */
  491. extern LVAL xltoofew();        /* report "too few arguments" */
  492. extern LVAL xlbadtype();    /* report "wrong argument type" */
  493. extern LVAL curinput();        /* get the current input port */
  494. extern LVAL curoutput();    /* get the current output port */
  495. #endif
  496.  
  497.